perm filename PARTS.F4[MSS,LCS]4 blob
sn#158099 filedate 1975-05-05 generic text, type T, neo UTF8
00100 C THIS AIDS IN EXTRACTING PARTS FROM SCORES. LOAD WITH MSFAIL.FAI
00200 DATA FIB/.5/
00300 DIMENSION XN(2000),RSTFAC(8),IV(78),LIST(200),PWDS(250),RN(2000)
00400 1,XWDS(250),STFF(8)
00500 C**** RN MIGHT HAVE TO BE 4000 ******
00600 COMMON /PX/POS,SX
00700
00800 14 JT=0
00900 JR=0
01000 REWIND 1
01100 1 FORMAT(' TYPE OUTPUT FILE NAME ',$)
01200 TYPE 1
01300 ACCEPT 2,NAME
01400 IF(LOOKD(NAME).GE.0)GO TO 13
01500 TYPE 88
01600 ACCEPT 2,L
01700 IF(L.EQ.'N')GO TO 14
01800 88 FORMAT(' WRITE OVER FILE???? '$)
01900 13 CALL OFILE(1,NAME)
02000 XWDS(1)=1
02100 RM=0
02200 L=1
02300 LX=1
02400 LP=1
02500 44 FORMAT(' TYPE TOP OUTPUT STAFF # ',$)
02600 TYPE 44
02700 ACCEPT 5,RS
02800 10 IF(JT.EQ.0)GO TO 83
02900 NAME=NAME+2
03000 GO TO 84
03100 86 FORMAT(1XA5)
03200 3 FORMAT(' TYPE INPUT NAME, (CONT), (NOBAR) ',$)
03300 83 TYPE 3
03400 ACCEPT 2,NAME,JT,NBAR
03500 C TYPE ANY NUMBER AFTER NAME AND IT WILL GO TO NEXT LETTER IN ALPH.
03600 IF(NBAR.NE.0)NBAR=-1
03700 C ANY THIRD NUM. SUPPRESSES SCORE BARLINE FEATURE
03800 84 LK=LP
03900 IF(LOOKD(NAME).GE.0)GO TO 20
04000 C FOUND NO MORE TO READ
04100 TYPE 86,NAME
04200 JZ=0
04300 IF(RM.NE.0)GO TO 77
04400 RM=-1
04500 4 FORMAT(' TYPE INST NAME -- '$)
04600 TYPE 4
04700 ACCEPT 2,RNAM
04710 IF(RNAM.GT.0)REREAD 5,SN
04800 IF(INM.EQ.'99')GO TO 20
04900 CC K=SN/100.
05000 TYPE 46
05100 46 FORMAT(' TRANS. NUM. -- '$)
05200 ACCEPT 5,TR
05300 IF(TR.GE.99)GO TO 83
05400 77 REWIND 21
05500 177 CALL IFILE(21,NAME)
05600 READ(21),ITEM,I,
05700 1 (PWDS(K),K=1,ITEM+1),(RN(K),K=1,I-1),ISCR,(IV(K),K=1,ISCR),
05800 1 LCNT,(LIST(K),K=1,LCNT),RSTFAC,STFF
05900 C TYPE 2ND NUM FOR TRANSPOSE, 3RD NUM FOR ALWAYS SAME STFF.
06000 DO 45 K=1,ITEM
06100 J=PWDS(K)
06200 IF(RN(J+1).NE.8)GO TO 45
06210 IF(RNAM)GO TO 145
06220 IF(RN(J+2).EQ.SN)GO TO 8
06230 GO TO 45
06290 145 R9=RN(J+9)
06295 TYPE 86,R9
06300 IF(R9.NE.RNAM)GO TO 45
06400 SN=RN(J+2)
06500 C FOUND THE STAFF
06600 GO TO 8
06700 45 CONTINUE
06800 L=JX
06900 LP=JY
07000 TYPE 16
07100 16 FORMAT(' STAFF NOT FOUND'/)
07200 GO TO 10
07300 8 DO 6 K=1,ITEM
07400 J=PWDS(K)
07500 IF(RN(J+1).NE.4)GO TO 80
07600 IF(NBAR)GO TO 80
07700 IF(RN(J).NE.2)GO TO 80
07800 C FOUND A BAR LINE
07900 KB=RN(J+4)/100.
08000 RN(J+4)=1.+KB*100.
08100 C KB IS FOR THICK BARS.
08200 R=RN(J+3)
08300 DO 82 KA=K+1,ITEM
08400 KB=PWDS(KA)
08500 IF(RN(KB+1).NE.4)GO TO 82
08600 IF(RN(KB).NE.2)GO TO 82
08700 C AVOIDS DUPLICATE BARS.
08800 IF(ABS(R-RN(KB+3)).GT..5)GO TO 82
08900 RN(KB+2)=99
09000 RN(KB+1)=0
09100 82 CONTINUE
09200 GO TO 81
09300 80 IF(RN(J+2).NE.SN)GO TO 6
09400 IF(RN(J+1).NE.8)GO TO 81
09500 IF(RN(J).LT.3)GO TO 81
09600 RN(J+4)=0
09700 C SETS VERT. POS. OF STAFF TO 0. WHAT ABOUT P5??!
09800 CC85 JZ=-1
09900 81 JA=PWDS(K+1)
10000 DO 7 KA=J,JA-1
10100 XN(LK)=RN(KA)
10200 7 LK=LK+1
10300 IF(L.GE.250)GO TO 150
10400 IF(LK.LE.2000)GO TO 50
10500 150 TYPE 9
10600 GO TO 20
10700 50 R=XN(LP+1)
11200 XN(LP+2)=RS
11300 L=L+1
11400 LP=LK
11500 XWDS(L)=LP
11600 6 CONTINUE
11700 17 JX=L
11800 JY=LP
11900 RS=RS-1
12000 C******↓↓↓↓↓↓ RHYTH RESET ↓↓↓↓↓↓↓↓
12100 M=LX+1
12200 J=XWDS(LX)
12300 PWDS(LX)=XWDS(LX)
12400 I=LX
12500 24 RA=10000.
12600 C POSITION
12700 DO 21 K=LX,L-1
12800 JL=XWDS(K)+3
12900 R=XN(JL)
13000 IF(R.EQ.10000)GO TO 21
13100 IF(ABS(R-RA).GT..1)GO TO 240
13200 R=RA
13300 XN(JL)=R
13400 C PUT IN HERE MULTI-VOICE TRAP
13500 GO TO 21
13600 240 IF(R.GT.RA)GO TO 21
13700 C LINES THEM UP
13800 I=K
13900 RA=R
14000 21 CONTINUE
14100 IF(RA.EQ.10000)GO TO 23
14200 C JUMP IF ALL SORTED
14300 JL=XWDS(I)
14400 LA=JL
14500 N=XN(JL)+3
14600 C NEXT POINTER
14700 PWDS(M)=PWDS(M-1)+N
14800 M=M+1
14900 DO 22 K=J,J+N-1
15000 RN(K)=XN(JL)
15100 22 JL=JL+1
15200 XN(LA+3)=10000
15300 C PUT IT ASIDE
15400 J=N+J
15500 GO TO 24
15600
15700 23 LB=LX
15710 JFST=0
15720 POS=0
15800 25 N=PWDS(LB)
15900 R=RN(N+1)
15910 IF(TR.EQ.0)GO TO 51
15915 IF(R.EQ.1)GO TO 52
15920 IF(R.EQ.5)GO TO 52
15925 IF(R.EQ.6)GO TO 52
15950 IF(R.EQ.17)GO TO 117
16000 51 IF(R.LE.4)GO TO 430
16050 IF(R.LT.17)GO TO 30
16075 C LOOKS FOR 17 AND 18, KSIG AND METER.
16100 430 IF(R.NE.1)GO TO 230
16200 IF(RN(N).LT.7)GO TO 30
16210 IF(RN(N+9))GO TO 30
16220 C SKIPS NON-LEDGER LINE NOTES.
16230 GO TO 530
16300 C LOOK ONLY AT NOTES AND RESTS AND NON-DOUBLE STOPS, AND BARS,CLEFS
16310 230 IF(R.NE.2)GO TO 330
16320 IF(RN(N).LT.5)GO TO 30
16330 C JUMP IF NO RHYTH VALUE FOUND IN P7 (P9 FOR NOTES)
16335 530 IF(JFST.NE.0)GO TO 130
16340 JFST=LB+1
16345 POS=RN(N+3)
16350 GO TO 130
16360 330 IF(JFST.EQ.0)GO TO 30
16362 C ONLY LOOKS AT ITEMS AFTER FIRST N0TE OR REST.
16365 IF(R.NE.4)GO TO 130
16382 IF(RN(N).NE.2)GO TO 30
16400 130 S=RN(N+3)
16500 LA=LB
16600 26 LA=LA+1
16700 IF(LA.GE.L)GO TO 30
16800 C FIND NEXT IMPORTANT ITEM
16900 NA=PWDS(LA)
17000 RR=RN(NA+1)
17100 IF(RR.LE.4)GO TO 134
17150 IF(RR.LT.17)GO TO 26
17200 134 IF(RR.NE.4)GO TO 34
17300 IF(RN(NA).NE.2)GO TO 26
17400 C USES ONLY NOTES, RESTS, BARS, CLEFS
17500 34 RX=RN(NA+3)
17600 C POSITION OF NEXT ITEM
17700 IF(S.EQ.RX)GO TO 26
17800 A=RX-2
17900 IF(A.LT.S)A=S+.5
18000 C SPACING WILL BEGIN NEARBY
18010 IF(R.LT.3)GO TO 235
18012 IF(R.GE.17)P=4.
18016 C PUT IN FOR LARGE KSIGS LATER.
18020 IF(R.EQ.4)P=2.
18030 IF(R.EQ.3)P=6.
18040 IF(RN(NA+5).GE.100.)P=5.
18050 C SPACE FOR BARS, KSIG, METERS, CLEFS (LAST FOR MINI-CLEF)
18055 IF(RR.EQ.17)P=P+3.
18057 C IF NEXT(RR) IS KSIG, ADD SPACE.
18060 GO TO 335
18100 235 K=9
18200 IF(R.EQ.2)K=7
18300 P=RN(N+K)
18400 P=P+(.125-P)*FIB
18500 135 P=P*15.
18600 C FINDS RHYTH IN P9 OR P7(REST)
18700 C IF DIFFERENT SIMULTANEOUS RHYTHMS, ZERO OUT LARGER BEFORE HAND.
18800 IF(P)GO TO 30
18900 C SKIPS NOTES WITH SUPPRESSED LEDGER LINES.
19000 335 SX=S+P-RX
19100 C SPACE DIFFERENCE
19200 35 DO 29 K=LX,L-1
19300 RR=SX
19400 NZ=PWDS(K)+3
19500 RA=RN(NZ)
19600
19700 IF(RA.LT.A)RR=RR*(RA-S)/(A-S)
19750 IF(RA.GT.S)RN(NZ)=RA+RR
19775 RR=SX
19800 C A=BASIC POS. AT THIS TIME.
19900 R=RN(NZ-2)
20000 IF(R4567(R))GO TO 29
20100 NZ=NZ-3
20200 IF(RN(NZ).EQ.2)GO TO 29
20300 RB=RN(NZ+6)
20400 IF(RB.LT.A)RR=RR*(RB-S)/(A-S)
20500 IF(RB.GT.S)RN(NZ+6)=RB+RR
20600 IF(R.EQ.6)CALL BMQ(RN,NZ,A)
21600 29 CONTINUE
21700 30 LB=LB+1
21800 IF(LB.LT.L)GO TO 25
21900 C GO BACK IF MORE SPACING TO DO
21950
22000 SX=(200.-POS)/(RN(IFIX(PWDS(L-1)+3))-POS)
22100 C `SHRINK' FACTOR
22200 DO 31 K=JFST,L-1
22300 N=PWDS(K)+3
22400 RN(N)=POSX(RN(N))
22500 R=RN(N-2)
22600 IF(R4567(R))GO TO 31
22700 N=N-3
22800 IF(RN(N).EQ.2)GO TO 31
23000 RN(N+6)=POSX(RN(N+6))
23100 IF(RN(N+1).EQ.6)CALL BMQ(RN,N,-1000.)
24100 31 CONTINUE
24200 DO 32 K=IFIX(PWDS(LX)),IFIX(PWDS(L))
24300 32 XN(K)=RN(K)
24400 DO 33 K=LX,L
24500 33 XWDS(K)=PWDS(K)
24600 C ALL DONE
24700 C****↑↑↑↑↑↑ RHYTH. RESET ↑↑↑↑↑↑↑↑↑↑↑
24800 LX=L
24900
25000 IF(RS.GT.-4)GO TO 10
25100 20 L=JX-1
25200 J=1
25300 WRITE(1),L,JY,
25400 1 (XWDS(K),K=1,L+1),(XN(K),K=1,JY-1),J,J,J,J,RSTFAC,STFF,IV,STFF
25500 C STUFF ON THE END IS FOR FORTRAN IO BUG.
25600 15 END FILE 1
25700 CALL EXIT
25800 2 FORMAT(A5,2I)
25900 5 FORMAT(5F)
26000 9 FORMAT(' NO ROOM FOR THIS ONE')
26100
26200
26300 52 A=RN(N+4)
26400 RN(N+4)=A+TR
26500 C TRANSPOSES ONLY BY STAFF STEPS FOR NOW
26600 X=RN(N+5)
26700 IF(RN(N+1).EQ.1)GO TO 11
26705 C COULD ADD STEM REVERS HERE.
26800 RN(N+5)=X+TR
26900 GO TO 51
27000 11 IF(TR.NE.4)GO TO 1101
27100 IF(AMOD(A,7.0).EQ.0)GO TO 101
27200 1101 IF(AMOD(TR-1.0,7.0).NE.0)GO TO 51
27300 C NEXT IS FOR Bb TRANSP.
27400 B=AMOD(A+7.0,7.0)
27500 IF(B.EQ.0)GO TO 101
27600 IF(B.NE.3)GO TO 51
27700 C FINDS ORIG. E OR B
27800 101 M=AMOD(X,10.0)
27900 C FINDS ACCID.
28000 X=X-M
28100 C STEM DIR. AND DECI.
28200 B=3.
28300 C CHANGES FLAT TO NATURAL SIGN.
28400 IF(M.EQ.0.OR.M.EQ.3)B=2
28500 C NO PROVISION YET FOR ## OR bb
28600 2101 RN(N+5)=X+B
28700 GO TO 51
28710 117 S=RN(N+5)
28720 IF(TR.EQ.1)S=S+2
28730 IF(TR.EQ.4)S=S+1
28740 C CHANGE KSIG FOR Bb AND F INSTS. ADD CHECK-UP ABOVE LATER.
28745 C MAKES NATURALS IF CHANGED TO NO KSIG (I.E. =0)
28747 IF(S.NE.0)GO TO 217
28748 IF(TR.EQ.1)S=-102
28749 IF(TR.EQ.3)S=-101
28750 217 RN(N+5)=S
28760 GO TO 51
28800 END
28900
29000 FUNCTION R4567(R)
29100 R4567=0
29200 IF(R.LT.4)GO TO 1
29300 IF(R.LE.7)RETURN
29400 1 R4567=-1
29500 END
29600
29700 SUBROUTINE BMQ(RN,NZ,A)
29800 DIMENSION RN(1)
30000 RR=RN(NZ)
30100 IF(RR.LT.7)RETURN
30200 C FOR IRREGULAR BEAMS (THERE ARE AT LEAST 9 PARAMS.)
30300 IF(RR.NE.7)GO TO 129
30400 429 IF(RN(NZ+8).NE.0)GO TO 229
30500 RETURN
30600 129 IF(RN(NZ+10).EQ.0)GO TO 429
30700 IF(RN(NZ+10).LT.30)GO TO 229
30800 RB=RN(NZ+8)
30900 IF(RB.GT.A)RN(NZ+8)=BMX(RB,A)
31000 229 RB=RN(NZ+9)
31100 IF(RB.GT.A)RN(NZ+9)=BMX(RB,A)
31200 END
31300
31400 FUNCTION BMX(RB,A)
31410 COMMON /PX/POS,SX
31500 BMX=RB+SX
31600 IF(A.EQ.-1000.)BMX=POSX(RB)
31700 END
31800
32000 FUNCTION POSX(R)
32100 COMMON /PX/POS,SX
32200 POSX=POS+(R-POS)*SX
32300 END